﻿{-# OPTIONS_GHC -XTemplateHaskell -XDeriveDataTypeable -fglasgow-exts #-}
module Text.XML.Light.Xmlable.TH where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.XML.Light.Xmlable.Types
import Text.XML.Light
import Control.Arrow
import Data.Maybe
import Data.Either
data T0 = T0

qRep :: Name -> Q Exp
qRep t = reify t >>= report False . show >> listE []

getCons :: Name -> Q [Con]
getCons t = do
    info <- reify t
    case info of
        TyConI dec -> case dec of
            DataD _ _ _ cons2 _ -> return cons2
            NewtypeD _ _ _ con2 _ -> return [con2]
            TySynD _ _ (ConT t') -> getCons t'
            TySynD _ _ t' -> report True ("invalid type synonym: " ++ show t') >> return []
            _ -> report True ("invalid dec: " ++ show dec) >> return []
        _ -> report True ("invalid info: " ++ show info) >> return []

conNameTypes :: Con -> Q (Name, [Type])
conNameTypes (RecC nm ts) = return (nm, map (\(_,_,t)->t) ts)
conNameTypes (NormalC nm ts) = return (nm, map snd ts)
conNameTypes x = report True ("Xmlable.TH.conNameTypes: unsupported constructor " ++ show x) >> newName "err" >>= return . flip (,) []

conName :: Con -> Q Name
conName = (>>= return . fst) . conNameTypes

conTypes :: Con -> Q [Type]
conTypes = (>>= return . snd) . conNameTypes

mkGetCons :: Name -> ExpQ
mkGetCons t2 = do
    x <- newName "x"
    cons2 <- getCons t2
    cps <- mapM (\a -> consWildPat a) cons2
    bodies <- mapM (\a -> consWildBody a) cons2
    return $ LamE [VarP x] (CaseE (VarE x) $ zipWith (\cp body -> Match cp body []) cps bodies)
    where

        consWildPat :: Con -> PatQ
        consWildPat (RecC cn fs) = consWildPat' cn fs
        consWildPat (NormalC cn fs) = consWildPat' cn fs
        consWildPat xxx = report True (show xxx) >> return WildP

        consWildPat' :: Name -> [a] -> PatQ
        consWildPat' cn = return . ConP cn . map (\_ -> WildP)

        consWildBody :: Con -> BodyQ
        consWildBody con = (conName con) >>= return . nameBase >>= \s -> [| s |] >>= return . NormalB

fSubElems :: [Con] -> ExpQ
fSubElems cons = do
    x <- newName "x"
    nss <- mapM (ns "a") cons
    cps <- sequence $ zipWith (\a b -> consPat a b) nss cons
    bodies <- sequence $ zipWith (\a b -> consBody a b) nss cons
    return $ LamE [VarP x] (CaseE (VarE x) $ zipWith (\cp body -> Match cp body []) cps bodies)
    where
        consPat :: [Name] -> Con -> PatQ
        consPat nss (RecC cn _) = consPat' nss cn
        consPat nss (NormalC cn _) = consPat' nss cn
        consPat _ xxx = report True (show xxx) >> return WildP
        consPat' nss cn = return $ ConP cn $ map (\v -> VarP v) nss

        constName :: Name -> ExpQ
        constName nm = do
                s <- return $ nameBase nm
                [| const s |]

        consBody :: [Name] -> Con -> BodyQ
        consBody nss (RecC _ fs) = consBody' nss $ mapM (\(nm, _, _) -> constName nm) fs
        consBody nss (NormalC _ fs) = consBody' nss $ mapM (\(_, t) -> name_con t) fs
        consBody _ xxx = report True (show xxx) >> ([|0|] >>= return . NormalB)
        consBody' nss fs = do
                fs' <- fs
                body <- sequence $ zipWith (\s n ->
                        [| ($(return s) $(return $ VarE n), elemAndSimple $(varE n)) |]
                    ) fs' nss
                return $ NormalB $ ListE body

        name_con :: Type -> ExpQ
        name_con (ConT nm) = mkGetCons nm
        name_con (AppT (ConT c1) con2)
            | show c1 == "GHC.Types.[]" = [| listName |]
            | show c1 == "Data.Maybe.Maybe" = [| \x -> $(name_con con2) (fromJust x) |]
            | otherwise = report True (unlines ["error in name_con (AppT (ConT c1) _)", show c1]) >> [|const "error"|]
        name_con x = report True (unlines ["error in name_con", show x]) >> [|const "error"|]

        ns :: String -> Con -> Q [Name]
        ns s (RecC _ fs) = mapM (const $ newName s) fs
        ns s (NormalC _ fs) = mapM (const $ newName s) fs
        ns _ xxx = report True (show xxx) >> return []

data TypeDesc = TypeDesc {
        tdName :: String,
        tdConsName :: [String],
        tdMinCount :: Int,
        tdMaxCount :: Maybe Int
        --,
        -- tdFromEl :: Exp
        --
        -- [[]] is not supplied in XML
        -- (Maybe []) or (Maybe Maybe) [Maybe] also not supported
    } deriving Show

data ConDesc = ConDesc {
        cdName :: String,
        cdIsOrdered :: Bool,
        cdChilds :: [TypeDesc]
    } deriving Show

getDesc :: Name -> Q [ConDesc]
getDesc t = do
    info <- reify t
    case info of
        TyConI dec -> case dec of
            DataD _ _ _ cons _ -> mkDescs cons
            NewtypeD _ _ _ con _ -> mkDescs [con]
            TySynD _ _ (ConT t') -> getDesc t'
            TySynD _ _ t' -> report True ("invalid type synonym: " ++ show t') >> return []
            _ -> report True ("invalid dec: " ++ show dec) >> return []
        _ -> report True ("invalid info: " ++ show info) >> return []
    where
        mkDescs = mapM mkDesc
        mkDesc :: Con -> Q ConDesc
        mkDesc (RecC nm ts) = do
            childs <- mkChilds False $ map (\(fn, _, typ) -> (nameBase fn, typ)) ts
            return $ ConDesc {
                    cdName = nameBase nm,
                    cdIsOrdered = False,
                    cdChilds = childs
                }
        mkDesc (NormalC nm ts) = do
            childs <- mkChilds True $ map (\(_, typ) -> ("", typ)) ts
            return $ ConDesc {
                    cdName = nameBase nm,
                    cdIsOrdered = True,
                    cdChilds = childs
                }

        mkChilds isOrdered = (>>= return . catMaybes) . mapM (mkChild isOrdered 1 (Just 1))
        mkChild :: Bool -> Int -> Maybe Int -> (String, Type) -> Q (Maybe TypeDesc)
        mkChild isOrdered mn mx (nm, typ) = case typ of
            ConT typName -> do
                consName <- if isOrdered then getCons typName >>= mapM conName >>= return . map nameBase else return [nm]
                return $ Just TypeDesc {
                    tdName = nameBase typName,
                    tdConsName = consName,
                    tdMinCount = mn,
                    tdMaxCount = mx
                    -- tdFromEl =
                }
            AppT (ConT c1) t2
                | show c1 == "GHC.Types.[]" -> mkChild isOrdered 0 Nothing (nm, t2)
                | show c1 == "Data.Maybe.Maybe" -> mkChild isOrdered 0 (Just 1) (nm, t2)
                | otherwise -> report True (unlines ["Xmlable.TH.getDesc: Invalid type ", show c1]) >> return Nothing
            x -> report True (unlines ["Xmlable.TH.getDesc: Invalid type ", show x]) >> return Nothing

-- getFromEl :: (Xmlable a) => [ConDesc] -> Element -> a
getFromEl cds e = mkElem' (filter ((== (qName . elName $ e)) . cdName) cds) (elemsFromElement e)
    where
        mkElem' [cd] es = mkElem cd es
        mkElem' cds _ = Left (unlines ["Xmlable.TH.getFromEl: Invalid desc ", show cds])
        mkElem cd es
            | cdIsOrdered cd = fromOrdered (cdChilds cd) es [] []
        fromOrdered tds [] _ _
            | not $ null $ filter ((>0) . tdMinCount) tds = Left $ unlines ["Xmlable.TH.getFromEl: Descrition is not empty but element is empty. ", show cds]
            | otherwise = Right $ map (const $ [blank_element]) tds
        {-
        fromOrdered (t:tds) (e:es) xs els
            | qName (elName e) == tdName t && (fromMaybe 2 tdMaxCount > 1) = fromOrdered (t:tds) es (e:xs) els
            | qName (elName e) == tdName t = undefined
        -}

deriveXmlable :: Bool -> Name -> String -> Q [Dec]
deriveXmlable isReport t listname = do
    TyConI dec <- reify t
    report False $ "start deriveXmlable" ++ show dec
    getDesc t >>= report False . show
    funcs <- case dec of
        NewtypeD _ typeName _ con@(NormalC cn [(_, ConT old)]) _ -> do
            getC <- do
                TyConI decOld <- reify old
                report False $ show decOld
                case decOld of
                    TySynD _ _ (AppT _ _) -> report False "newtype T String. Isn't it?" >> [| const "err" |]
                    _ -> mkGetCons old
            z <- newName "z"
            f <- return $ LamE [ConP cn [VarP z]] (VarE z)
            return (typeName,
                ([| isSimple . $(return f) |],
                    ([| \x -> toElement ($(return f) x) |],
                        [| \x -> [($(return getC) $ $(return f) x, elemAndSimple $ $(return f) x)] |])))

        DataD _ typeName _ cons _ -> do
            return (typeName,
                ([| const $ Just False |],
                    ([| const blank_element |],
                        fSubElems cons)))

    (s, uri) <- return $ (nameBase &&& Just . mkURI . fromMaybe "" . nameModule) $ fst funcs
    d <- [d|
        instance Xmlable T0 where
            listName = const listname
            isSimple = $(fst . snd $ funcs)
            toElement x
                | isNothing (isSimple x) = blank_element
                | fromJust (isSimple x) = $(fst . snd . snd $ funcs) x
                | otherwise = Element {
                    elName = name $ $(mkGetCons t) x, -- name s,
                    elAttribs = mkAttrs args,
                    elContent = mkContents args,
                    elLine = Nothing
                }
                where
                    name ss = QName ss uri Nothing
                    args = map (first name) ($(snd . snd . snd $ funcs) x)
            fromElement e = undefined
                where
                    name ss = QName ss uri Nothing
                    elems = elemsFromElement e
                    -- vals =
                {-
                fromList $ elemsFromElement e
                where
                    name s = QName s uri Nothing
                    fromList xs = $(apps $ return (ConE consName) : (zipWith (\n _ -> [| getVal n |]) [0..] $ eNames!!0))
                        where
                            getVal n = valFromElems s (map name $ eNames!!0) xs n
                -}
        |]
--    xxx -> report True (show xxx) >> return []
    let    [InstanceD [] (AppT xt (ConT _T0)) fs] = d
    if isReport then report False $ pprint [InstanceD [] (AppT xt (ConT t  )) fs] else return ()
    return [InstanceD [] (AppT xt (ConT t  )) fs]
